COMMENT ⊗   VALID 00011 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	.SBTTL Interpreter
C00006 00003	Interpreter itself: INTERP
C00010 00004	  GETARG, GETSCA, GETVEC, GETTRN
C00014 00005	Stack ops: GTVAL, CHNGE, POP, COPY, REPLACE, FLUSH
C00016 00006	Flow-of-control: PROC, RETURN
C00022 00007	  FORCHK, SPROUT, JUMP, JUMPZ
C00026 00008	return scalars: SADD, SSUB, SMUL, SDIV, SNEG, VDOT, PVDOT, VMAG
C00032 00009	Vector utilities:  UNITV, CROSV
C00038 00010	Return vectors: SVMUL, TVMUL, VMAKE, VADD
C00042 00011	Return a trans: TMAKE, TTMUL
C00046 ENDMK
C⊗;
.SBTTL Interpreter

;Register uses in the interpreter:
;	R3	interpreter stack pointer
;	R4	points to interpreter status block

;Each interpreter has a stack which it uses to store pointers to
;currently "open" variables.  During the course of a calculation,
;operands and temporary result cells will be open in this fashion.
;The "interpreter stack" is pointed to by R3. When a new interpreter
;is sprouted, it is given a new stack area. Each interpreter has
;certain status information which facilitates transfer of control
;between interpreters.  This information is kept in the interpreter
;status block, which is always pointed to by R4.  Most important are
;the IPC, the Interpreter Program Counter, the ENV, which points to
;the local environment, and LEV, which stores the current lexical
;level.

;Each procedure has an environment, which is a data area holding
;information vital to that procedure.  This includes pointers to all
;the variables local to that procedure, and return information.

	INSTSZ == 20	;Size of an interpreter stack

;Interpreter status block
	II == 0
	XX SR0	;Saved R0 (across waits)
	XX SR1	;Saved R1 (across waits)
	XX SR2	;Saved R2 (across waits)
	XX SR3	;Saved R3 (across waits)
	XX SR4	;Saved R4 (across waits)
	XX SRF	;Saved RF (across waits)
	XX SSP	;Saved SP (across waits)
	XX SPC	;Saved PC (across waits)
	XX IPC	;Interpreter program counter
	XX STKBAS ;Location of start of stack area.  Needed
		;for eventual reclamation.
	XX ICR	;Interpreter cross-reference (to HAL code)
	XX ENV	;Location of local environment
	XX LEV	;Lexical level of current execution
	XX STA	;Status bits for condition codes:  0 means all well.
	ISBS = II/2	;Size (in words) of interpreter status block

;Fixed fields in the environment of each process
	II == 0
	XX SLINK 	;Pointer to environment of next (outer, lower
			;  numbered) block
	XX OLEV		;Old level.  The lexical level of calling process.
	XX OENV		;Old environment, the one for the calling process.
	XX OIPC		;Old IPC.  Program counter for calling process.
	XX LVARS	;First location where pointers to local variables go

;Interpreter itself: INTERP

INTERP:	MOV @IPC(R4),R0	;R0 ← next instruction
	BLT INTER1	;Instruction out of range
	CMP R0,INSEND	;Is instruction too large?
	BHI INTER1	;Yes.
	ADD #2,IPC(R4)	;Bump IPC
	JSR PC,@INTOPS(R0)	;Call the appropriate routine
	BR  INTCPL(R0)	;R0 should have an completion code.  Branch accordingly.

INTCPL: BR  INTSTS	;No error.  Gather statistics.
	JMP RUG		;Error.  Temporarily, just go to RUG.

INTSTS: BR  INTERP	;No statistics code written yet.

INTER1:	HALERR INTMS1
INTMS1:	ASCIE /INTERPRETER INSTRUCTION OUT OF RANGE/

	.MACRO MAKEOP CNAME, ANAME	;Compiler name, Address name
	XX	CNAME
	ANAME
	.ENDM

INTOPS:
	II == 0		;Start of interpreter jump table
	;Motion control
	;PREPMOVE
	;STARTMOVE

	;Stack operations
MAKEOP	XGTVAL,GTVAL;a	;Push value of arg (level-offset pair).
MAKEOP  XCHNGE,CHNGE;a	;Pop value into arg (level-offset pair).
MAKEOP	XPUSH, PUSH ;a	;Push arg directly (as a ptr) onto stack. For cnstnts.
MAKEOP	XPOP,  POP	;Pop stack.
MAKEOP	XCOPY, COPY ;n	;Copy n'th down to top of stack.
MAKEOP	XREPLAC,REPLAC;n;Replace n'th down with top (which pop)
MAKEOP	XFLUSH,FLUSH	;Flush the entire stack.

	;Flow of control
MAKEOP	XJUMP, JUMP ;a	;Jump to address
MAKEOP	XJUMPZ,JUMPZ;a	;Jump to address only if top zero (which pop)
	;TERMINATE
MAKEOP  XPROC, PROC;d,al;Call a procedure at d, with arg list al.
MAKEOP	XRETURN,RETURN	;Return from procedure
MAKEOP	XSPROUT,SPROUT;d;Sprout an interpreter at d.
	;WAIT
MAKEOP	XFORCHK,FORCHK;d;Do a FOR-loop check, and fail to location d.

	;Arithmetic
MAKEOP	XSADD, SADD	;S+S:  Add top two elts, pop, pop, push answer
MAKEOP	XSSUB, SSUB	;S-S:  Sub top two elts, pop, pop, push answer
MAKEOP	XSMUL, SMUL	;S*S:  Mul top two elts, pop, pop, push answer
MAKEOP	XSDIV, SDIV	;S/S:  Div top two elts, pop, pop, push answer
MAKEOP	XSNEG, SNEG	;-S:   Negate top elt, pop, push answer
MAKEOP	XVMAG, VMAG	;Scalar ← norm of vector
MAKEOP	XSVMUL,SVMUL	;Vector ← scalar * vector
MAKEOP	XVDOT, VDOT	;S ← vector dot vector
MAKEOP	XPVDOT,PVDOT	;S ← vector dot vector
MAKEOP	XVMAKE,VMAKE	;V ← vector(scalar,scalar,scalar)
MAKEOP	XVADD, VADD	;V ← vector + vector
	;UNITV remove	;Vector ← vector / its norm
	;CROSV remove	;Vector ← vector cross vector
MAKEOP	XTVMUL,TVMUL	;Vector ← trans * vector
	;FTOF
MAKEOP	XTMAKE,TMAKE	;Trans ← trans(rot,vector)
	;TTMUL
	;TINV
	INSEND = II	;Marks the end of the instructions
;  GETARG, GETSCA, GETVEC, GETTRN

GETARG:
;Arguments:  
;  R0=variable name:  low byte is lexical level, high byte is offset.
;  R4=pointer to interpreter status block.
;Result:
;  R0← pointer to address of desired variable.  
;  R1 clobbered.
;This routine returns in R0 a pointer to the location in the current
;  environment (or, if necessary, more global environment) which
;  points to the variable which is named in R0. 
	MOV R2,-(SP)	;Save R2
	MOVB R0,R1	;R1 ← Lexical level desired
	CLRB R0		;
	SWAB R0		;R0 ← Offset
	MOV ENV(R4),R2	;R2 ← LOC[local environment]
	SUB LEV(R4),R1	;R1 ← Difference in levels: desired-got
	BEQ GTRG1	;Diff=0; can use R2 as pointer at right base.
	BHI GTERR	;If diff>0, then value inaccessible.
GTRG2:	MOV SLINK(R2),R2;Must go up a level.  R2 ← LOC[more global environment]
	INC R1		;R1 ← New difference in levels
	BNE GTRG2	;If not yet good, then move up another level
GTRG1:	ADD R2,R0	;R0 ← environment + offset = location of desired pointer
	MOV (SP)+,R2	;Restore R2.
	RTS PC		;Done.
GTERR:	HALERR GTMS1
GTMS1:	ASCIE /ATTEMPT TO ACCESS UNAVAILABLE VARIABLE/

GETSCA:	;Gets place for a scalar result, and places a pointer on
	;the interpreter stack.  Location is returned in R0.  
	;Simple procedure.
;	MOV #2,R0	;Number of words needed
;	JSR PC,GETSMA	;R0 ← LOC[new block]
	MOV #RES,R0	;Temporary kludge.  Delete this line in final runs.
	MOV R0,-(R3)	;Push new value cell pointer on interpreter stack.
	RTS PC		;Done

GETVEC:	;Gets place for a vector result, and places a pointer on
	;the interpreter stack.  Location is returned in R0.  
	;Simple procedure.
;	MOV #10,R0	;Number of words needed
;	JSR PC,GETSMA	;R0 ← LOC[new block]
	MOV #RES,R0	;Temporary kludge.  Delete this line in final runs.
	MOV R0,-(R3)	;Push new value cell pointer on interpreter stack.
	RTS PC		;Done

GETTRN:	;Gets place for a trans result, and places a pointer on
	;the interpreter stack.  Location is returned in R0.  
	;Simple procedure.
;	MOV #40,R0	;Number of words needed
;	JSR PC,GETSMA	;R0 ← LOC[new block]
	MOV #RES,R0	;Temporary kludge.  Delete this line in final runs.
	MOV R0,-(R3)	;Push new value cell pointer on interpreter stack.
	RTS PC		;Done

;Stack ops: GTVAL, CHNGE, POP, COPY, REPLACE, FLUSH

GTVAL:	MOV @IPC(R4),R0	;Pick up level-offset name of argument
	ADD #2,IPC(R4)	;Bump IPC
	JSR PC,GETARG	;R0 ← LOC[LOC[desired graph node]]
	MOV (R0),R0	;R0 ← LOC[desired graph node]
	CALL GETVAL,<R0>;R0 ← value
	MOV R0,-(R3)	;Push value on interpreter stack.
	CLR R0		;Clear condition code.
	RTS PC		;Done

CHNGE:	MOV @IPC(R4),R0	;Pick up level-offset name of argument
	ADD #2,IPC(R4)	;Bump IPC
	JSR PC,GETARG	;R0 ← LOC[LOC[Desired graph node]]
	MOV (R0),R0	;R0 ← LOC[Desired graph node]
	CALL CHANGE,<R0,(R3)>
POP:	TST (R3)+	;Pop stack
	CLR R0		;Clear condition code.
	RTS PC		;Done

COPY:	MOV @IPC(R4),R0	;Pick up argument.
	ADD #2,IPC(R4)	;Bump IPC
	ADD R3,R0	;R0 ← LOC[stack element to be copied to top]
	MOV (R0),-(R3)	;Copy it onto top of stack.
	CLR R0		;Clear condition code.
	RTS PC		;Done

REPLAC:	MOV @IPC(R4),R0	;Pick up argument.
	ADD #2,IPC(R4)	;Bump IPC
	ADD R3,R0	;R0 ← LOC[stack element to be copied into]
	MOV -(R3),(R0)	;Copy top of stack into it.
	CLR R0		;Clear condition code.
	RTS PC		;Done

FLUSH:	MOV STKBAS(R4),R3;Reset the stack base.
	CLR R0		;Clear condition code.
	RTS PC		;Done
;Flow-of-control: PROC, RETURN

PROC:
;Procedure call.  Arguments: 
;	Destination.
;	List of variables which are to be inserted in appropriate 
;	  locations in the local storage of procedure.  These are
;	  in the format variable (ie level-offset pair), new offset
;	  (right justified in the second word).
;	  There is a zero word to finish these.
;At the destination address can be found:
	II == 0
	XX FSLGTH	;Number of words to get from free storage 
			;for local variable pointers
	XX PLEV		;Lexical level of procedure
	DSLGTH == II	;Number of words before code starts
;Value parameters should have first been copied first into local temps
;  (which have been arranged by the compiler), and then the temps are
;  passed by reference.  Eventual problem: to know which variables to
;  really kill as the procedure is exited. 

	MOV R2,-(SP)	;Save R2
	MOV @IPC(R4),R2	;R2 ← LOC[destination]
	ADD #2,IPC(R4)	;Bump IPC
	MOV FSLGTH(R2),R0	;R0 ← Number of words to get.
	JSR PC,GTFREE	;R0 ← LOC[block with that number of words]

      ;initialize pointer to lexical level:
	MOV PLEV(R2),R1	;R1 ← Lexical level of procedure
	MOV ENV(R4),R2	;R2 ← LOC[current environment]
	SUB LEV(R4),R1	;R1 ← Difference in levels: desired-got
	BEQ PRC1	;Diff=0; can use R2 as pointer at right environment.
PRC2:	MOV SLINK(R2),R2;No, must go up a level.  R2 ← LOC[base of upper area]
	INC R1		;R1 ← New difference in levels
	BNE PRC2	;If not yet good, then move up another level
PRC1:	MOV R2,SLINK(R0);SLINK[new environment] ← correct global environment

      ;Put copies of local variables in new area
	MOV R0,-(SP)	;Stack LOC[new environment]
	MOV @IPC(R4),R0	;R0 ← level-offset pair for an argument
	BEQ PRC3	;If there are no more, go to next phase
PRC4:	ADD #2,IPC(R4)	;Else bump IPC
	JSR PC,GETARG	;R0 ← LOC[LOC[graph node]]
	MOV @IPC(R4),R1	;R1 ← offset in new block
	ADD #2,IPC(R4)	;Bump IPC
	ADD (SP),R1	;R1 ← LOC[place in new environment to put pointer]
	MOV (R0),(R1)	;new environment gets pointer to LOC[argument graph node]
	MOV @IPC(R4),R0	;R0 ← level-offset pair for an argument
	BNE PRC4	;If there are more, go back and treat them
PRC3:	ADD #2,IPC(R4)	;Bump IPC one last time

      ;Save the old context in the new area
	MOV (SP)+,R1	;R1 ← LOC[new environment]
	MOV LEV(R4),OLEV(R1)	;Store the old level
	MOV ENV(R4),OENV(R1)	;Store the old environment location
	MOV IPC(R4),OIPC(R1)	;Store the return address

      ;Set up the new context for procedure
	MOV PLEV(R2),LEV(R4)	;New lexical level
	MOV R1,ENV(R4)	;New environment location
	ADD #DSLGTH,R2	;R2 ← Place where execution should begin
	MOV R2,IPC(R4)	;New program counter
	MOV (SP)+,R2	;Restore R2
	CLR R0		;Clear condition code.
	RTS PC		;Done


RETURN:
;Returns from a procedure call to calling program. Since variables are
;passed by reference, it is not necessary to do any copying of values.
;All that is needed is to restore the context of the caller and to
;discard the display.
	MOV ENV(R4),R0	;R0 ← LOC[current environment]
	MOV OLEV(R0),LEV(R4)	;Restore the old lexical level
	MOV OENV(R0),ENV(R4)	;Restore the old environment
	MOV OIPC(R0),IPC(R4)	;Restore the IPC
	JSR PC,RLFREE	;Release storage of old display
	CLR R0		;Clear condition code.
	RTS PC		;Done
;  FORCHK, SPROUT, JUMP, JUMPZ

FORCHK:	
;Assume that the stack has, from surface in, the increment, the
;  final value, and the control variable's value, all of which are
;  scalar values.  If (FINAL-CONVAR)*(INCREMENT) ≥ 0 then this is a
;  no-op; otherwise, jump to the destination. 
;Arguments:  destination.
	LDF @2(R3),AC0	;AC0 ← final value
	SUBF @4(R3),AC0	;AC0 ← final - current
	MULF @(R3),AC0	;AC0 ← (final - current)*increment
	MOV @IPC(R4),R0	;R0 ← destination
	ADD #2,IPC(R4)	;Bump IPC
	CFCC		;
	BGE FOR1	;Shall this be a no-op?
	MOV R0,IPC(R4)	;No; set new IPC.
FOR1:	CLR R0		;
	RTS PC		;Done


       .MACRO NEWPRC ADDR, PRIORT, STABLK
	;Makes a new process, to begin execution at ADDR, with
	;priority PRIORT, and whose status block is at STABLK.
       .ENDM

SPROUT:
;Takes one argument: the address of the code which the new interpreter
;is to execute.  The new interpreter is given an interpreter status
;block and is then scheduled.
	MOV #ISBS,R0	;R0 ← Size (in words) of an interpreter status block
	JSR PC,GTFREE	;R0 ← LOC[new interpreter status block]
	MOV @IPC(R4),IPC(R0)	;new IPC ← jump address
	ADD #2,IPC(R4)		;Bump IPC
	MOV ENV(R4),ENV(R0)	;new ENV ← old ENV
	MOV LEV(R4),LEV(R0)	;new LEV ← old LEV
	MOV R0,-(SP)	;Save LOC[new interpreter status block]
	MOV #INSTSZ,R0	;R0 ← Size needed for an interpreter stack
	JSR PC,GTFREE	;R0 ← LOC[new interpreter stack]
	MOV (SP)+,R1	;R1 ← LOC[new interpreter status block]
	MOV R0,STKBAS(R0)	;Store away new stack base
	ADD #INSTSZ,R0	;R0 ← LOC[top of new stack]
	MOV R0,SR3(R1)	;Store away new stack pointer
	MOV R1,SR4(R1)	;Store away new interp.status block ptr.
	NEWPRC <INTERP,1,(R0)>	;Sprout new interpreter
	CLR R0		;Clear condition code.
	RTS PC		;Done

JUMP:
;Takes one argument: the new address.
	MOV @IPC(R4),IPC(R4)
	CLR R0		;Clear condition code.
	RTS PC		;Done

JUMPZ:
;Takes one argument: the new address.  Jumps if top of stack is zero.
	MOV (R3)+,R0	;R0 ← LOC[arg]
	MOV (R0),AC0	;AC0 ← arg
	CFCC		;
	BNE JMPZ1	;Zero?
	MOV @IPC(R4),IPC(R4)  ;Yes
JMPZ1:	CLR R0		;Clear condition code.
	RTS PC		;Done
;return scalars: SADD, SSUB, SMUL, SDIV, SNEG, VDOT, PVDOT, VMAG

;All timings are averages of 1000 runs.  They take into account
;the cost of the RTS but not the JSR.  It is assumed that GETSCA
;and GETVEC take no time.

;30 microseconds
SADD:	;Scalar ← Scalar + Scalar
	LDF @(R3)+,AC0	;AC0 ← arg 2
	ADDF @(R3)+,AC0	;AC0 ← arg2 + arg1
	JSR PC,GETSCA	;R0 ← -(R3) ← LOC[new scalar block]
	STF AC0,(R0)	;Store result
	CLR R0		;Clear condition code.
	RTS PC		;Done

SSUB:	;Scalar ← Scalar - Scalar
	LDF @2(R3),AC0	;AC0 ← arg 1
	SUBF @(R3)+,AC0	;AC0 ← arg1 - arg2
	TST (R3)+	;Move past first argument
	JSR PC,GETSCA	;R0 ← -(R3) ← LOC[new scalar block]
	STF AC0,(R0)	;Store result
	CLR R0		;Clear condition code.
	RTS PC		;Done

;30 microseconds
SMUL:	;Scalar ← scalar * scalar
	LDF @(R3)+,AC0	;AC0 ← arg 2
	MULF @(R3)+,AC0	;AC0 ← arg2 * arg1
	JSR PC,GETSCA	;R0 ← -(R3) ← LOC[new scalar block]
	STF AC0,(R0)	;Store result
	CLR R0		;Clear condition code.
	RTS PC		;Done

;33 microseconds
SDIV:	;Scalar ← Scalar / Scalar
	LDF @(R3)+,AC1	;AC1 ← arg 2
	LDF @(R3)+,AC0	;AC0 ← arg 1
	DIVF AC1,AC0	;AC0 ← arg1 / arg2
	JSR PC,GETSCA	;R0 ← -(R3) ← LOC[new scalar block]
	STF AC0,(R0)	;Store result
	CLR R0		;Clear condition code.
	RTS PC		;Done

;26 microseconds
SNEG:	;Scalar ← -Scalar
	LDF @(R3)+,AC0	;AC0 ← arg
	NEGF AC0	;AC0 ← -arg
	JSR PC,GETSCA	;R0 ← -(R3) ← LOC[new scalar block]
	STF AC0,(R0)	;Store result
	CLR R0		;Clear condition code.
	RTS PC		;Done

;96 -- 116 microseconds
VDOT:	;Scalar ← Vector dot Vector
	;S ← (X1X2 + Y1Y2 + Z1Z2) / W1W2
	MOV R2,-(SP)	;Save R2.
	MOV (R3)+,R1	;R1 ← LOC[arg 2]
	MOV (R3)+,R0	;R0 ← LOC[arg 1]
	CLRF AC0	;AC0 ← 0.  Running total
	MOV #3,R2	;R2 ← 3:  Length of vector
VDV1:	LDF (R0)+,AC1	;Form sum of products of first 3 terms
	MULF (R1)+,AC1	;
	ADDF AC1,AC0	;
	SOB R2,VDV1	;Loop until all 3 fields done.
	DIVF (R0),AC0	;Divide by W1
	DIVF (R1),AC0	;Divide by W2.  AC0 now has answer.
	JSR PC,GETSCA	;R0 ← -(R3) ← LOC[new scalar block]
	STF AC0,(R0)	;Store result
	MOV (SP)+,R2	;Restore R2
	CLR R0		;Clear condition code.
	RTS PC		;Done

;103 -- 116 microseconds
PVDOT:	;Scalar ← Plane dot Vector
	;S ← X1X2 + Y1Y2 + Z1Z2 + W1W2
	MOV R2,-(SP)	;Save R2.
	MOV (R3)+,R1	;R1 ← LOC[arg 2]
	MOV (R3)+,R0	;R0 ← LOC[arg 1]
	CLRF AC0	;AC0 ← 0.  Running total
	MOV #4,R2	;R2 ← 4:  Length of vector and weight
PDV1:	LDF (R0)+,AC1	;Form sum of products of all 4 terms
	MULF (R1)+,AC1	;
	ADDF AC1,AC0	;
	SOB R2,PDV1	;Loop until all 3 fields done.
	JSR PC,GETSCA	;R0 ← -(R3) ← LOC[new scalar block]
	STF AC0,(R0)	;Store result
	MOV (SP)+,R2	;Restore R2
	CLR R0		;Clear condition code.
	RTS PC		;Done

;199 -- 207 microseconds
VMAG:	;Scalar ← Norm (vector)
	;S ← SQRT(XX + YY+ ZZ) / W
	MOV (R3)+,R1	;R1 ← LOC[arg]
	LDF (R1)+,AC0	;AC0 ← X
	MULF AC0,AC0	;AC0 ← XX
	LDF (R1)+,AC1	;AC1 ← Y
	MULF AC1,AC1	;AC1 ← YY
	ADDF AC1,AC0	;AC0 ← XX + YY
	LDF (R1)+,AC1	;AC1 ← Z
	MULF AC1,AC1	;AC1 ← ZZ
	ADDF AC1,AC0	;AC0 ← XX + YY + ZZ
	MOV R1,-(SP)	;Push LOC[W] onto system stack, to save across SQRTF
	JSR PC,SQRTF	;AC0 ← SQRT(XX + YY + ZZ)
	DIVF @(SP)+,AC0	;AC0 ← AC0 / W
	JSR PC,GETSCA	;R0 ← -(R3) ← LOC[new scalar block]
	STF AC0,(R0)	;Store answer
	CLR R0		;Clear condition code.
	RTS PC		;Done
;Vector utilities:  UNITV, CROSV

;281 -- 286 microseconds  *** maybe don't need this procedure
UNITV:	;Vector ← V / Norm(V)
	;S ← SQRT(XX + YY+ ZZ) / W
	MOV R2,-(SP)	;Save R2
	MOV (R3),R1	;R1 ← LOC[arg]
	LDF (R1)+,AC0	;AC0 ← X
	MULF AC0,AC0	;AC0 ← XX
	LDF (R1)+,AC1	;AC1 ← Y
	MULF AC1,AC1	;AC1 ← YY
	ADDF AC1,AC0	;AC0 ← XX + YY
	LDF (R1)+,AC1	;AC1 ← Z
	MULF AC1,AC1	;AC1 ← ZZ
	ADDF AC1,AC0	;AC0 ← XX + YY + ZZ
	MOV R1,-(SP)	;Save R1 across SQRTF
	JSR PC,SQRTF	;AC0 ← SQRT(XX + YY + ZZ)
	MOV (SP)+,R1	;Restore R1
	DIVF (R1),AC0	;AC0 ← Norm = SQRT / W
	MOV (R3)+,R1	;R1 ← LOC[arg]
	JSR PC,GETVEC	;R0 ← -(R3) ← LOC[new vector block]
	MOV #3,R2	;R2 ← count of fields
UNITV1:	LDF (R1)+,AC1	;AC1 ← field of vector
	DIVF AC0,AC1	;divide by norm
	STF AC1,(R0)+	;Store result
	SOB R2,UNITV1	;Loop until done
	MOV (R1)+,(R0)+	;Copy W.
	MOV (R1),(R0)	;   (two words long)
	MOV (SP)+,R2	;Restore R2
	CLR R0		;Clear condition code
	RTS PC		;Done

;172 -- 184 microseconds  *** maybe don't need this procedure
CROSV:	;Vector ← Vector cross Vector
	;X ← Y1Z2 - Y2Z1
	;Y ← X2Z1 - X1Z2
	;Z ← X1Y2 - X2Y1
	;W ← W1W2
	;AC0, 1, 2, 3, 4, 5 are garbaged by this routine.
	MOV R2,-(SP)	;Save R2
	MOV (R3),R2	;R2 ← LOC[arg 2]
	JSR PC,GETVEC	;R0 ← -(R3) ← LOC[new vector block]
	MOV 4(R3),R1	;R1 ← LOC[arg 1].  Must not pop R3 stack yet!
	LDF 14(R1),AC0	;AC0 ← W1
	MULF 14(R2),AC0	;AC0 ← W1W2
	STF AC0,14(R0)	;Store AC0 → W
	LDF 4(R1),AC0	;AC0 ← Y1
	LDF (R2),AC1	;AC1 ← X2
	LDF 4(R2),AC2	;AC2 ← Y2
	LDF (R1),AC3	;AC3 ← X1
	STF AC3,AC4	;AC4 ← X1
	STF AC0,AC5	;AC5 ← Y1
	MULF AC2,AC3	;AC3 ← X1Y2
	MULF AC1,AC0	;AC0 ← X2Y1
	SUBF AC0,AC3	;AC3 ← X1Y2 - X2Y1
	STF AC3,10(R0)	;Z ← AC3
	LDF 10(R2),AC0	;AC0 ← Z2
	LDF 10(R1),AC3	;AC3 ← Z1
	MULF AC4,AC0	;AC0 ← X1Z2
	MULF AC3,AC1	;AC1 ← X2Z1
	SUBF AC0,AC1	;AC1 ← X2Z1 - X1Z2
	STF AC1,4(R0)	;Y ← AC1
	LDF 10(R2),AC0	;AC0 ← Z2
	MULF AC5,AC0	;AC0 ← Y1Z2
	MULF AC2,AC3	;AC3 ← Y2Z1
	SUBF AC3,AC0	;AC0 ← Y1Z2 - Y2Z1
	STF AC0,(R0)	;X ← AC0
	MOV (R3)+,2(R3)	;Put result cell where first argument was
	TST (R3)+	;Put stack pointer in right place
	MOV (SP)+,R2	;Restore R2
	CLR R0		;Clear condition code
	RTS PC		;Done

;Return vectors: SVMUL, TVMUL, VMAKE, VADD

;83 -- 91 microseconds
SVMUL:	;Vector ← Scalar * Vector
	;X ← S*X,  Y ← S*Y,  Z ← S*Z,  W ← W
	MOV R2,-(SP)	;Save R2
	MOV (R3)+,R1	;R1 ← LOC[vector]
	LDF @(R3)+,AC0	;AC0 ← scalar;
	JSR PC,GETVEC	;R0 ← -(R3) ← LOC[new vector block]
	MOV #3,R2	;R2 ← 3:  How many fields to handle
SVM1:	LDF (R1)+,AC1	;AC1 ← next field of vector
	MULF AC0,AC1	;AC1 ← product
	STF AC1,(R0)+	;Store result
	SOB R2,SVM1	;Loop until all 3 fields done.
	MOV (R1)+,(R0)+	;Transfer W
	MOV (R1)+,(R0)+	;  which is 2 words long.
	MOV (SP)+,R2	;Restore R2
	CLR R0		;Clear condition code
	RTS PC		;Done

VMAKE:
	LDF @(R3)+,AC1	;Fetch X
	LDF @(R3)+,AC2	;Fetch Y
	LDF @(R3)+,AC3	;Fetch Z
	JSR PC,GETVEC	;R0 ← -(R3) ← LOC[new vector]
	STF AC1,(R0)+	;Store X
	STF AC2,(R0)+	;Store Y
	STF AC3,(R0)+	;Store Z
	MOV ONE,(R0)+	;Store W
	CLR (R0)	;Store W (second word)
	CLR R0		;Clear condition code
	RTS PC		;Done

VADD:
	MOV (R3)+,R0	;R0 ← LOC[arg 1]
	MOV (R3)+,R1	;R1 ← LOC[arg 1]
	LDF (R0)+,AC1	;Calculate X
	ADDF (R1)+,AC1	;
	LDF (R0)+,AC2	;Calculate Y
	ADDF (R1)+,AC2	;
	LDF (R0)+,AC3	;Calculate Z
	ADDF (R1)+,AC3	;
	JSR PC,GETVEC	;R0 ← -(R3) ← LOC[new vector]
	STF AC1,(R0)+	;Store X
	STF AC2,(R0)+	;Store Y
	STF AC3,(R0)+	;Store Z
	MOV ONE,(R0)+	;Assume W is 1
	CLR (R0)	;
	CLR R0		;Clear condition code
	RTS PC		;Done

;283 -- 324 microseconds
TVMUL:	;Vector ← Trans * Vector
	MOV R2,-(SP)	;Save R2
	MOV (R3),R2	;R2 ← LOC[vector]
	MOV 2(R3),R0	;R0 ← LOC[trans]
	CLRF AC1	;X ← 0
	CLRF AC2	;Y ← 0
	CLRF AC3	;Z ← 0
	MOV #4,R1	;R1 ← How many columns left to go
TVM1:	LDF (R2)+,AC0	;AC0 ← field of vector
	STF AC0,AC5	;AC5 ← copy of AC0
	MULF (R0)+,AC0	;
	ADDF AC0,AC1	;Add partial result to X
	LDF AC5,AC0	;Restore AC0
	MULF (R0)+,AC0	;
	ADDF AC0,AC2	;Add partial result to Y
	LDF AC5,AC0	;Restore AC0
	MULF (R0)+,AC0	;
	ADDF AC0,AC3	;Add partial result to Z.
	ADD #4,R0	;Skip bottom row
	SOB R1,TVM1	;Go back to do all 4 columns.
	JSR PC,GETVEC	;R0 ← -(R3) ← LOC[new vector]
	STF AC1,(R0)+	;Store X
	STF AC2,(R0)+	;Store Y
	STF AC3,(R0)+	;Store Z
	MOV -4(R2),(R0)+;Copy W from the vector
	MOV -2(R2),(R0)	;  (2 words long)
	MOV (R3)+,2(R3)	;Put result cell where first argument was
	TST (R3)+	;Put stack pointer in right place
	MOV (SP)+,R2	;Restore R2
	CLR R0		;Clear condition code
	RTS PC		;Done

ONE:	40200		;First word of floating 1.000 (second word zero)
;Return a trans: TMAKE, TTMUL

TMAKE:
;All that is required is to take the rot part of the first argument,
;and the vector from the second part;
	MOV R2,-(SP)	;Save R2
	MOV (R3)+,R1	;R1 ← LOC[arg 1]
	MOV (R3)+,-(SP)	;Push LOC[arg 2]
	JSR PC,GETTRN	;R0 ← -(R3) ← LOC[new trans]
	MOV #14,R2	;R2 ← Count of how many copies to make
TMK1:	MOV (R1)+,(R0)+	;Transfer first half of floating word
	MOV (R1)+,(R0)+	;Transfer second half of floating word
	SOB R2,TMK1	;Repeat until done
	MOV (SP)+,R1	;R1 ← LOC[arg 2]
	MOV #4,R2	;R2 ← Count of how many copies to make
TMK2:	MOV (R1)+,(R0)+	;Transfer first half of floating word
	MOV (R1)+,(R0)+ ;Transfer second half of floating word
	SOB R2,TMK2	;Repeat until done
	MOV (SP)+,R2	;Restore R2
	CLR R0		;Clear condition code.
	RTS PC		;Done.

TTMUL:
;Multiplies two transes together.  Takes advantage of the fact that
;last row is 0 0 0 1. 
	MOV R2,-(SP)	;Save R2
	MOV (R3)+,R2	;R2 ← LOC[arg 2]
	MOV (R3)+,R1	;R1 ← LOC[arg 1]
	JSR PC,GETTRN	;R0 ← -(R3) ← LOC[new trans]
	MOV R3,-(SP)	;Save R3
	MOV R4,-(SP)	;Save R4
	MOV #4,R4	;Loop count for cols of answer
	MOV R1,-(SP)	;Save a copy of R1
TTM2:	LDF (R2)+,AC1	;Pick up a column of arg2: First row
	LDF (R2)+,AC2	;  Second row
	LDF (R2)+,AC3	;  Third row
	STF AC3,AC4	;    store in AC4
	ADD #4,R2	;  Fourth row is zero
	MOV #3,R3	;Loop count for rows of answer
TTM1:	LDF (R1),AC3	;First col of arg 1
	MULF AC1,AC3	;
	LDF 20(R1),AC0	;Second col of arg 1
	MULF AC2,AC0	;
	ADDF AC0,AC3	;
	LDF 40(R1),AC0	;Third col of arg 1
	MULF AC4,AC0	;
	ADDF AC0,AC3	;
	STF AC3,(R0)+	;
	ADD #4,R1	;Move to next column of arg 1
	SOB R3,TTM1	;Repeat for first 3 rows of answer
	CLR (R0)+	;Last row of answer is zero
	CLR (R0)+	;
	MOV (SP),R1	;Reset R1 to point to first row of arg 1
	SOB R4,TTM2	;Repeat for all four columns of answer
	LDF -20(R0),AC1	;Add correction for last column, first row
	ADDF 60(R1),AC1	;
	STF AC1,-20(R0)	;
	LDF -14(R0),AC1	;Add correction for last column, second row
	ADDF 64(R1),AC1	;
	STF AC1,-14(R0)	;
	LDF -10(R0),AC1	;Add correction for last column, third row
	ADDF 70(R1),AC1	;
	STF AC1,-10(R0)	;
	MOV ONE,-4(R0)	;Make last col, last row get a one.
	TST (SP)+	;Pop the R1 temp
	MOV (SP)+,R4	;Restore R4
	MOV (SP)+,R3	;Restore R3
	MOV (SP)+,R2	;Restore R2
	CLR R0		;Clear condition code
	RTS PC		;Done